Shareware Grab Bag/Shareware Grab Bag.iso/005/dates.arc/DATES.PAS

Pascal/Delphi Source File | 1987-10-27 | 5.1 KB | 198 lines

{$R-,S+,I-,D-,T-,F-,V-,B-,N-}

unit Dates;

{ A unit providing Julian day numbers and date manipulations.

  Version 1.00 - 10/26/1987 - First general release

  Scott Bussinger
  Professional Practice Systems
  110 South 131st Street
  Tacoma, WA  98444
  [phone]
  Compuserve 72247,2671 }


interface

const BlankDate = $FFFF;                         { Constant for Not-a-real-Date }

type Date = Word;
     Day = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);

function ValidDate(Day,Month,Year: integer): boolean;
  { Check if the day,month,year is a real date storable in a Date variable }

procedure DMYtoDate(Day,Month,Year: integer;var Julian: Date);
  { Convert from day,month,year to a date }

procedure DateToDMY(Julian: Date;var Day,Month,Year: integer);
  { Convert from a date to day,month,year }

function BumpDate(Julian: Date;Days,Months,Years: integer): Date;
  { Add (or subtract) the number of days, months, and years to a date }

function DayOfWeek(Julian: Date): Day;
  { Return the day of the week for the date }

function DayString(WeekDay: Day): string;
  { Return a string version of a day of the week }

function MonthString(Month: integer): string;
  { Return a string version of a month }

function DateToStr(Julian: Date): string;
  { Convert a date to a sortable string }

function StrToDate(StrVar: string): Date;
  { Convert a sortable string form to a date }


implementation

function ValidDate(Day,Month,Year: integer): boolean;
  { Check if the day,month,year is a real date storable in a Date variable }
  begin
  if (Day<1) or (Year<1900) or (Year>2078)
   then
    ValidDate := false
   else
    case Month of
      1,3,5,7,8,10,12: ValidDate := Day <= 31;
      4,6,9,11: ValidDate := Day <= 30;
      2: ValidDate := Day <= 28 + ord((Year mod 4)=0)*ord(Year<>1900)
      else ValidDate := false
      end
  end;

procedure DMYtoDate(Day,Month,Year: integer;var Julian: Date);
  { Convert from day,month,year to a date }
  { Stored as number of days since January 1, 1900 }
  { Note that no error checking takes place in this routine -- use ValidDate }
  begin
  if (Year=1900) and (Month<3)
   then
    if Month = 1
     then
      Julian := pred(Day)
     else
      Julian := Day + 30
   else
    begin
    if Month > 2
     then
      dec(Month,3)
     else
      begin
      inc(Month,9);
      dec(Year)
      end;
    dec(Year,1900);
    Julian := (1461*longint(Year) div 4) + ((153*Month+2) div 5) + Day + 58
    end
  end;

procedure DateToDMY(Julian: Date;var Day,Month,Year: integer);
  { Convert from a date to day,month,year }
  var LongTemp: longint;
      Temp: integer;
  begin
  if Julian <= 58
   then
    begin
    Year := 1900;
    if Julian <= 30
     then
      begin
      Month := 1;
      Day := succ(Julian)
      end
     else
      begin
      Month := 2;
      Day := Julian - 30
      end
    end
   else
    begin
    LongTemp := 4*longint(Julian) - 233;
    Year := LongTemp div 1461;
    Temp := LongTemp mod 1461 div 4 * 5 + 2;
    Month := Temp div 153;
    Day := Temp mod 153 div 5 + 1;
    inc(Year,1900);
    if Month < 10
     then
      inc(Month,3)
     else
      begin
      dec(Month,9);
      inc(Year)
      end
    end
  end;

function BumpDate(Julian: Date;Days,Months,Years: integer): Date;
  { Add (or subtract) the number of days, months, and years to a date }
  { Note that months and years are added first before days }
  { Note further that there are no overflow/underflow checks }
  var Day: integer;
      Month: integer;
      Year: integer;
  begin
  DateToDMY(Julian,Day,Month,Year);
  Month := Month + Months - 1;
  Year := Year + Years + (Month div 12) - ord(Month<0);
  Month := (Month + 12000) mod 12 + 1;
  DMYtoDate(Day,Month,Year,Julian);
  BumpDate := Julian + Days
  end;

function DayOfWeek(Julian: Date): Day;
  { Return the day of the week for the date }
  begin
  DayOfWeek := Day(succ(Julian) mod 7)
  end;

function DayString(WeekDay: Day): string;
  { Return a string version of a day of the week }
  const DayStr: array[Sunday..Saturday] of string[9] =
          ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  begin
  DayString := DayStr[WeekDay]
  end;

function MonthString(Month: integer): string;
  { Return a string version of a month }
  const MonthStr: array[1..12] of string[9] =
          ('January','February','March','April','May','June','July','August','September','October','November','December');
  begin
  MonthString := MonthStr[Month]
  end;

function DateToStr(Julian: Date): string;
  { Convert a date to a sortable string }
  const Result: record
          case integer of
            0: (Len: byte;
                W: word);
            1: (Str: string[2])
          end = (Str:'  ');
  begin
  Result.W := swap(Julian);
  DateToStr := Result.Str
  end;

function StrToDate(StrVar: string): Date;
  { Convert a sortable string form to a date }
  var Temp: record
        Len: byte;
        W: word
        end absolute StrVar;
  begin
  StrToDate := swap(Temp.W)
  end;

end.